home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / H406.ZIP / TOTSRC11.ZIP / TOTSTR.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-04  |  22KB  |  906 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.10                             }
  6.  
  7. Unit totSTR;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes:  1.00a  6/11/91   Corrected RealSciStr for 0.0
  12.                      1.00b  2/03/92   Further corrections to RealToSciStr
  13.                                       and ValidInt
  14.                      1.00c  2/27/92   Remove double negative from RealtoSciStr
  15.                      1.00d  3/09/92   Changed NthNumber routine
  16. }
  17.  
  18. INTERFACE
  19.  
  20. Uses totREAL, totINPUT;
  21.  
  22. CONST
  23.    MaxFixlength = 5;
  24.  
  25. TYPE
  26.    tJust = (JustLeft,JustCenter,JustRight);
  27.    tCase = (Lower,Upper,Proper,Leave);
  28.    tSign = (plusminus, minus, brackets, dbcr);
  29.  
  30.    pFmtNumberOBJ = ^FmtNumberOBJ;
  31.    FmtNumberOBJ = object
  32.       vPrefix: string[Maxfixlength];
  33.       vSuffix: string[Maxfixlength];
  34.       vSign: tSign;
  35.       vPad: char;
  36.       vThousandsSep: char;
  37.       vDecimalSep: char;
  38.       vJustification: tJust;
  39.       {...methods}
  40.       constructor Init;
  41.       procedure   SetPrefixSuffix(P,S:string);
  42.       procedure   SetSign(S:tSign);
  43.       procedure   SetSeparators(P,T,D:char);
  44.       procedure   SetJustification(J:tJust);
  45.       function    GetDecimal:char;
  46.       function    FormattedStr(StrVal:string; Width:byte):string;
  47.       function    FormattedLong(Val:longint; Width:byte):string;
  48.       function    FormattedReal(Val:extended; DP:byte; Width:byte):string;
  49.       destructor  Done;
  50.    end; {FmtNumberOBJ}
  51.  
  52. CONST
  53.    Floating = 255;
  54.    Fmtchars: set of char = ['!','#','@','*'];
  55.  
  56. function PicFormat(Input,Picture:string;Pad:char): string;
  57. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  58. function Squeeze(L:char;Str:string;Width:byte): string;
  59. function First_Capital_Pos(Str:string): byte;
  60. function First_Capital(Str:string): char;
  61. function Pad(PadJust:tJust;Str:string;Size:byte;ChPad:char):string;
  62. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  63. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  64. function PadRight(Str:string;Size:byte;ChPad:char):string;
  65. function Last(N:byte;Str:string):string;
  66. function First(N:byte;Str:string):string;
  67. function AdjCase(NewCase:tCase;Str:string):string;
  68. function SetUpper(Str:string):string;
  69. function SetLower(Str:string):string;
  70. function SetProper(Str:string):string;
  71. function OverType(N:byte;StrS,StrT:string):string;
  72. function Strip(L,C:char;Str:string):string;
  73. function LastPos(C:char;Str:string):byte;
  74. function PosAfter(C:char;Str:string;Start:byte):byte;
  75. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  76. function PosWord(Wordno:byte;Str:string):byte;
  77. function WordCnt(Str:string):byte;
  78. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  79. function ValidInt(Str:string):boolean;
  80. function ValidHEXInt(Str:string):boolean;
  81. function ValidReal(Str:string):boolean;
  82. function StrToInt(Str:string):integer;
  83. function StrToLong(Str:string):Longint;
  84. function HEXStrToLong(Str:string):longint;
  85. function StrToReal(Str:string):extended;
  86. function RealToStr(Number:extended;Decimals:byte):string;
  87. function IntToStr(Number:longint):string;
  88. function IntToHEXStr(Number:longint):string;
  89. function Decimals (L:byte):byte;
  90. function RealToSciStr(Number:extended; D:byte):string;
  91. function NthNumber(InStr:string;Nth:byte) : char;
  92.  
  93. IMPLEMENTATION
  94.  
  95. function PicFormat(Input,Picture:string;Pad:char): string;
  96. {}
  97. var
  98.    TempStr : string;
  99.    I,J : byte;
  100. begin
  101.    J := 0;
  102.    For I := 1 to length(Picture) do
  103.    begin
  104.        If not (Picture[I] in Fmtchars) then
  105.        begin
  106.            TempStr[I] := Picture[I] ;  {force any none format charcters into string}
  107.            inc(J);
  108.        end
  109.        else    {format character}
  110.        begin
  111.            If I - J <= length(Input) then
  112.               TempStr[I] := Input[I - J]
  113.            else
  114.               TempStr[I] := Pad;
  115.        end;
  116.    end;
  117.    TempStr[0] := char(length(Picture));  {set initial byte to string length}
  118.    PicFormat := Tempstr;
  119. end; {PicFormat}
  120.  
  121. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  122. {}
  123. var
  124.    L : byte;
  125. begin
  126.    if Start > 1 then
  127.       Delete(Input,1,pred(Start));
  128.    L := length(Input);
  129.    if L = Len then
  130.       TruncFormat := Input
  131.    else if L > Len then
  132.       TruncFormat := copy(Input,1,Len)
  133.    else
  134.       TruncFormat := Padleft(Input,Len,Pad);
  135. end; {TruncFormat}
  136.  
  137. function Squeeze(L:char; Str:string;Width:byte): string;
  138. {}
  139. const more:string[1] = #26;
  140. var temp : string;
  141. begin
  142.    if Width = 0 then
  143.    begin
  144.       Squeeze := '';
  145.       exit;
  146.    end;
  147.    Fillchar(Temp[1],Width,' ');
  148.    Temp[0] := chr(Width);
  149.    if Length(Str) < Width then
  150.       move(Str[1],Temp[1],length(Str))
  151.    else
  152.    begin
  153.       if upcase(L) = 'L' then
  154.       begin
  155.          move(Str[1],Temp[1],pred(width));
  156.          move(More[1],Temp[Width],1);
  157.       end
  158.       else
  159.       begin
  160.          move(More[1],Temp[1],1);
  161.          move(Str[length(Str)-width+2],Temp[2],pred(width));
  162.       end;
  163.    end;
  164.    Squeeze := Temp;
  165. end; {Squeeze}
  166.  
  167. function First_Capital_Pos(Str : string): byte;
  168. {}
  169. var StrPos : byte;
  170. begin
  171.    StrPos := 1;
  172.    while (StrPos <= length(Str))  and (AlphabetTOT^.IsUpper(ord(Str[StrPos])) = false) do
  173.       StrPos := Succ(StrPos);
  174.    if StrPos > length(Str) then
  175.       First_Capital_Pos  := 0
  176.    else
  177.       First_Capital_Pos := StrPos;
  178. end; {First_Capital_Pos}
  179.  
  180. function First_capital(Str : string): char;
  181. {}
  182. var B : byte;
  183. begin
  184.    B := First_Capital_Pos(Str);
  185.    if B > 0 then
  186.       First_Capital := Str[B]
  187.    else
  188.       First_Capital := #0;
  189. end; {First_capital}
  190.  
  191. function Pad(PadJust:tJust;Str:string;Size:byte;ChPad:char):string;
  192. {}
  193. begin
  194.    case PadJust of
  195.       JustLeft:  Pad := PadLeft(Str,Size,ChPad);
  196.       JustCenter:Pad := PadCenter(Str,Size,ChPad);
  197.       JustRight: Pad := PadRight(Str,Size,ChPad);
  198.    end; {case}
  199. end; {Pad}
  200.  
  201. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  202. var temp : string;
  203. begin
  204.    fillchar(Temp[1],Size,ChPad);
  205.    Temp[0] := chr(Size);
  206.    if Length(Str) <= Size then
  207.       move(Str[1],Temp[1],length(Str))
  208.    else
  209.       move(Str[1],Temp[1],size);
  210.    PadLeft := Temp;
  211. end;
  212.  
  213. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  214. var temp : string;
  215. L : byte;
  216. begin
  217.    fillchar(Temp[1],Size,ChPad);
  218.    Temp[0] := chr(Size);
  219.    L := length(Str);
  220.    if L <= Size then
  221.       move(Str[1],Temp[((Size - L) div 2) + 1],L)
  222.    else
  223.       Temp := copy(Str,1,L);
  224.    PadCenter := temp;
  225. end; {center}
  226.  
  227. function PadRight(Str:string;Size:byte;ChPad:char):string;
  228. var
  229.   temp : string;
  230.   L : integer;
  231. begin
  232.    fillchar(Temp[1],Size,ChPad);
  233.    Temp[0] := chr(Size);
  234.    L := length(Str);
  235.    if L <= Size then
  236.       move(Str[1],Temp[succ(Size - L)],L)
  237.    else
  238.       move(Str[1],Temp[1],size);
  239.    PadRight := Temp;
  240. end;
  241.  
  242. function Last(N:byte;Str:string):string;
  243. var Temp : string;
  244. begin
  245.    if N > length(Str) then
  246.       Temp := Str
  247.    else
  248.       Temp := copy(Str,succ(length(Str) - N),N);
  249.    Last := Temp;
  250. end;  {Last}
  251.  
  252. function First(N:byte;Str:string):string;
  253. var Temp : string;
  254. begin
  255.    if N > length(Str) then
  256.       Temp := Str
  257.    else
  258.       Temp := copy(Str,1,N);
  259.    First := Temp;
  260. end;  {First}
  261.  
  262. function AdjCase(NewCase:tCase;Str:string):string;
  263. {}
  264. begin
  265.    case Newcase of
  266.    Upper: Str := SetUpper(Str);
  267.    Lower: Str := SetLower(Str);
  268.    Proper: Str := SetProper(Str);
  269.    Leave:{do nothing};
  270.    end;
  271.    AdjCase := Str;
  272. end; {AdjCase}
  273.  
  274. function SetUpper(Str:string):string;
  275. var
  276.   I : integer;
  277. begin
  278.    for I := 1 to length(Str) do
  279.       Str[I] := AlphabetTOT^.GetUpcase(Str[I]);
  280.    SetUpper := Str;
  281. end;  {Upper}
  282.  
  283. function SetLower(Str:string):string;
  284. var
  285.   I : integer;
  286. begin
  287.    for I := 1 to length(Str) do
  288.       Str[I] := AlphabetTOT^.GetLocase(Str[I]);
  289.    SetLower := Str;
  290. end;  {Lower}
  291.  
  292. function SetProper(Str:string):string;
  293. var
  294.   I : integer;
  295.   SpaceBefore: boolean;
  296. begin
  297.    SpaceBefore := true;
  298.    Str := SetLower(Str);
  299.    For I := 1 to length(Str) do
  300.       if SpaceBefore and AlphabetTOT^.IsLower(ord(Str[I])) then
  301.       begin
  302.          SpaceBefore := False;
  303.          Str[I] := AlphabetTOT^.GetUpcase(Str[I]);
  304.       end
  305.       else
  306.          if (SpaceBefore = False) and (Str[I] = ' ') then
  307.             SpaceBefore := true;
  308.    SetProper := Str;
  309. end;
  310.  
  311. function OverType(N:byte;StrS,StrT:string):string;
  312. {Overlays StrS onto StrT at Pos N}
  313. var
  314.   L : byte;
  315.   StrN : string;
  316. begin
  317.    L := N + pred(length(StrS));
  318.    if L < length(StrT) then
  319.       L := length(StrT);
  320.    if L > 255 then
  321.       Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  322.        else
  323.    begin
  324.       fillchar(StrN[1],L,' ');
  325.       StrN[0] := chr(L);
  326.       move(StrT[1],StrN[1],length(StrT));
  327.       move(StrS[1],StrN[N],length(StrS));
  328.       OverType := StrN;
  329.    end;
  330. end;  {OverType}
  331.  
  332. function Strip(L,C:char;Str:string):string;
  333. {L is left,center,right,all,ends}
  334. var I :  byte;
  335. begin
  336.    Case Upcase(L) of
  337.    'L' : begin       {Left}
  338.             while (Str[1] = C) and (length(Str) > 0) do
  339.                Delete(Str,1,1);
  340.          end;
  341.    'R' : begin       {Right}
  342.             while (Str[length(Str)] = C) and (length(Str) > 0) do
  343.                Delete(Str,length(Str),1);
  344.          end;
  345.    'B' : begin       {Both left and right}
  346.             while (Str[1] = C) and (length(Str) > 0) do
  347.                Delete(Str,1,1);
  348.             while (Str[length(Str)] = C) and (length(Str) > 0)  do
  349.                Delete(Str,length(Str),1);
  350.          end;
  351.    'A' : begin       {All}
  352.             I := 1;
  353.             repeat
  354.                if (Str[I] = C) and (length(Str) > 0) then
  355.                   Delete(Str,I,1)
  356.                else
  357.                   I := succ(I);
  358.             until (I > length(Str)) or (Str = '');
  359.          end;
  360.    end;
  361.    Strip := Str;
  362. end;  {Strip}
  363.  
  364. function LastPos(C:char;Str:string):byte;
  365. {}
  366. Var I : byte;
  367. begin
  368.    I := succ(Length(Str));
  369.    repeat
  370.       dec(I);
  371.    until (I = 0) or (Str[I] = C);
  372.    LastPos := I;
  373. end;  {LastPos}
  374.  
  375. function PosAfter(C:char;Str:string;Start:byte):byte;
  376. {}
  377. Var I : byte;
  378. begin
  379.    I := length(Str);
  380.    if (I = 0) or (Start > I) then
  381.       PosAfter := 0
  382.    else
  383.    begin
  384.       dec(Start);
  385.       repeat
  386.         inc(Start)
  387.       until (Start > I) or (Str[Start] = C);
  388.       if Start > I then
  389.          PosAfter := 0
  390.       else
  391.          PosAfter := Start;
  392.    end;
  393. end; {PosAfter}
  394.  
  395. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  396. {}
  397. begin
  398.    Str := copy(Str,1,Last);
  399.    LastPosBefore := LastPos(C,Str);
  400. end; {LostPosBefore}
  401.  
  402. function LocWord(StartAT,Wordno:byte;Str:string):byte;
  403. {local proc used by PosWord and Extract word}
  404. var
  405.   W,L: integer;
  406.   Spacebefore: boolean;
  407. begin
  408.    if (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  409.    begin
  410.        LocWord := 0;
  411.        exit;
  412.    end;
  413.    SpaceBefore := true;
  414.    W := 0;
  415.    L := length(Str);
  416.    StartAT := pred(StartAT);
  417.    while (W < Wordno) and (StartAT <= length(Str)) do
  418.    begin
  419.       StartAT := succ(StartAT);
  420.       if SpaceBefore and (Str[StartAT] <> ' ') then
  421.       begin
  422.          W := succ(W);
  423.          SpaceBefore := false;
  424.       end
  425.       else
  426.          if (SpaceBefore = false) and (Str[StartAT] = ' ') then
  427.             SpaceBefore := true;
  428.    end;
  429.    if W = Wordno then
  430.       LocWord := StartAT
  431.    else
  432.       LocWord := 0;
  433. end;
  434.  
  435. function PosWord(Wordno:byte;Str:string):byte;
  436. begin
  437.    PosWord := LocWord(1,wordno,Str);
  438. end;  {Word}
  439.  
  440. function WordCnt(Str:string):byte;
  441. var
  442.   W,I: integer;
  443.   SpaceBefore: boolean;
  444. begin
  445.    if Str = '' then
  446.    begin
  447.       WordCnt := 0;
  448.       exit;
  449.    end;
  450.    SpaceBefore := true;
  451.    W := 0;
  452.    For  I :=  1 to length(Str) do
  453.    begin
  454.       if SpaceBefore and (Str[I] <> ' ') then
  455.       begin
  456.          W := succ(W);
  457.          SpaceBefore := false;
  458.       end
  459.       else
  460.          if (SpaceBefore = false) and (Str[I] = ' ') then
  461.             SpaceBefore := true;
  462.    end;
  463.    WordCnt := W;
  464. end;
  465.  
  466. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  467. var Start, finish : integer;
  468. begin
  469.    if Str = '' then
  470.    begin
  471.       ExtractWords := '';
  472.       exit;
  473.    end;
  474.    Start := LocWord(1,StartWord,Str);
  475.    if Start <> 0 then
  476.       finish := LocWord(Start,succ(NoWords),Str)
  477.    else
  478.    begin
  479.       ExtractWords := '';
  480.       exit;
  481.    end;
  482.    if finish = 0 then
  483.       finish := succ(length(Str));
  484.    repeat
  485.       finish := pred(finish);
  486.    until Str[finish] <> ' ';
  487.    ExtractWords := copy(Str,Start,succ(finish-Start));
  488. end;  {ExtractWords}
  489.  
  490. function ValidInt(Str:string):boolean;
  491. {}
  492. var 
  493.   Temp : longint;
  494.   Code : integer;
  495.  
  496.   function NoLetters:boolean;
  497.   var 
  498.     I:integer;
  499.     Bad: boolean;
  500.   begin
  501.      NoLetters := true;
  502.      for I := 1 to Length(Str) do
  503.      begin
  504.         if (Str[I] in ['0'..'9','+','-']) = false then  {1.00b}
  505.            NoLetters := false;
  506.      end;
  507.   end;
  508.  
  509. begin
  510.    if length(Str) = 0 then
  511.       ValidInt := true
  512.    else
  513.    begin
  514.       val(Str,temp,code);
  515.       ValidInt := (Code = 0) and Noletters;
  516.    end;
  517. end; {ValidInt}
  518.  
  519. function ValidHEXInt(Str:string):boolean;
  520. {}
  521. var 
  522.   Temp : longint;
  523.   Code : integer;
  524. begin
  525.    if length(Str) = 0 then
  526.       ValidHEXInt := true
  527.    else
  528.    begin
  529.       val(Str,temp,code);
  530.       ValidHEXInt := (Code = 0);
  531.    end;
  532. end; {ValidHEXInt}
  533.  
  534. function IntToStr(Number:longint):string;
  535. {}
  536. var Temp : string;
  537. begin
  538.    Str(Number,temp);
  539.    IntToStr := temp;
  540. end; {IntToStr}
  541.  
  542. function IntToHEXStr(Number:longint):string;
  543. {}
  544. const
  545.    HEXChars: array [0..15] of char = '0123456789ABCDEF';
  546. var
  547.    I : integer;
  548.    Str : string;
  549.    BitsToShift: byte;
  550.    Chr : char;
  551. begin
  552.    Str := '';
  553.    for I := 7 downto 0 do
  554.    begin
  555.       BitsToShift := I*4;
  556.       Chr := HEXChars[ (Number shr BitsToShift) and $F];
  557.       if not ((Str = '') and (Chr = '0')) then
  558.          Str := Str + Chr;
  559.    end;
  560.    IntToHEXStr := Str;
  561. end; {IntToHEXStr}
  562.  
  563. function ValidReal(Str:string):boolean;
  564. {}
  565. var
  566.   Code : integer;
  567.   Temp : extended;
  568. begin
  569.    if length(Str) = 0 then
  570.       ValidReal := true
  571.    else
  572.    begin
  573.       if Copy(Str,1,1)='.' Then
  574.          Str:='0'+Str;
  575.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  576.          Insert('0',Str,2);
  577.       if Str[length(Str)] = '.' then
  578.          Delete(Str,length(Str),1);
  579.       val(Str,temp,code);
  580.       ValidReal := (Code = 0);
  581.    end;
  582. end; {ValidReal}
  583.  
  584. function StrToReal(Str:string):extended;
  585. var
  586.   code : integer;
  587.   Temp : extended;
  588. begin
  589.    if length(Str) = 0 then
  590.       StrToReal := 0
  591.    else
  592.    begin
  593.       if Copy(Str,1,1)='.' Then
  594.          Str:='0'+Str;
  595.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  596.          Insert('0',Str,2);
  597.       if Str[length(Str)] = '.' then
  598.          Delete(Str,length(Str),1);
  599.       val(Str,temp,code);
  600.       if code = 0 then
  601.          StrToReal := temp
  602.       else
  603.          StrToReal := 0;
  604.    end;
  605. end; {StrToReal}
  606.  
  607. function RealToStr(Number:extended;Decimals:byte):string;
  608. var Temp : string;
  609. begin
  610.    Str(Number:20:Decimals,Temp);
  611.    repeat
  612.         if copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  613.    until copy(temp,1,1) <> ' ';
  614.    if Decimals = Floating then
  615.    begin
  616.       Temp := Strip('R','0',Temp);
  617.       if Temp[Length(temp)] = '.' then
  618.          Delete(temp,Length(temp),1);
  619.    end;
  620.    RealToStr := Temp;
  621. end; {RealToStr}
  622.  
  623. function StrToInt(Str:string):integer;
  624. var temp,code : integer;
  625. begin
  626.    if length(Str) = 0 then
  627.       StrToInt := 0
  628.    else
  629.    begin
  630.       val(Str,temp,code);
  631.       if code = 0 then
  632.          StrToInt := temp
  633.       else
  634.          StrToInt := 0;
  635.    end;
  636. end; {StrToInt}
  637.  
  638. function StrToLong(Str:string):Longint;
  639. var
  640.   code : integer;
  641.   Temp : longint;
  642. begin
  643.    if length(Str) = 0 then
  644.       StrToLong := 0
  645.    else
  646.    begin
  647.       val(Str,temp,code);
  648.       if code = 0 then
  649.          StrToLong := temp
  650.       else
  651.          StrToLong := 0;
  652.    end;
  653. end; {StrToLong}
  654.  
  655. function HEXStrToLong(Str:string):longint;
  656. {}
  657. begin
  658.    if Str = '' then
  659.       HEXStrToLong := 0
  660.    else
  661.    begin
  662.       if Str[1] <> '$' then
  663.          Str := '$'+Str;
  664.       HEXStrtoLong := StrToLong(Str);
  665.    end;
  666. end; {HEXStrToLong}
  667.  
  668. function Decimals (L:byte):byte;
  669. {}
  670. var
  671.   Expnt:byte;
  672.   Temp :shortint;
  673. begin
  674. {$IFDEF FLOAT}
  675.       Expnt := 4;
  676. {$ELSE}
  677.    {$IFDEF FLOATEM}
  678.       Expnt := 4;
  679.    {$ELSE}
  680.       Expnt := 2;
  681.    {$ENDIF}        
  682. {$ENDIF}
  683.    Temp := L-Expnt-5;
  684.    if temp > 0 then
  685.       Decimals := Temp
  686.    else
  687.       Decimals := 0;
  688. end; {Decimals}
  689.  
  690. function RealToSciStr(Number:extended; D:byte):string;         {1.00b,1.00c}
  691. {Credits: Michael Harris, Houston. 
  692.           Peter Sands, Australia
  693.           Frans van Capelle, Amsterdam
  694.  Thanks!}
  695. Const
  696.     DamnNearUnity = 9.99999999E-01;
  697. Var
  698.     Temp : extended;
  699.     Power: integer;
  700.     Value: string;
  701.     Sign : char;
  702.     Expnt: byte;
  703. begin
  704.    if Number = 1.0 then
  705.       RealToSciStr := '1.000'
  706.    else if Number = 0.0 then   {1.00a}
  707.       RealToSciStr := '0.000'
  708.    else
  709.    begin
  710.       Temp := Number;
  711.       Power := 0;
  712.       if abs(Number) > 1.0 then
  713.       begin
  714.          while abs(Temp) >= 10.0 do
  715.          begin
  716.              Inc(Power);
  717.              Temp := Temp/10.0;
  718.          end;
  719.          Sign := '+';
  720.       end
  721.       else
  722.       begin
  723.          while abs(Temp) < DamnNearUnity do
  724.          begin
  725.              Inc(Power);
  726.              Temp := Temp * 10.0;
  727.          end;
  728.          Sign := '-';
  729.       end;
  730.       Value := RealToStr(Temp,D);
  731. {$IFDEF FLOAT}
  732.       Expnt := 4;
  733. {$ELSE}
  734.    {$IFDEF FLOATEM}
  735.       Expnt := 4;
  736.    {$ELSE}
  737.       Expnt := 2;
  738.    {$ENDIF}        
  739. {$ENDIF}        
  740.       RealToSciStr := Value+'E'+Sign+Padright(IntToStr(Power),Expnt,'0');
  741.    end;
  742. end; {RealToSciStr}
  743.  
  744. function NthNumber(InStr:string;Nth:byte) : char;
  745. {Returns the nth number in an alphanumeric string}
  746. var
  747.    Counter : byte;
  748.    B, Len : byte;
  749. begin
  750.     Counter := 0;
  751.     B := 0;
  752.     Len := Length(InStr);
  753.     Repeat
  754.          Inc(B);
  755.          If InStr[B] in ['0'..'9'] then
  756.             Inc(Counter);
  757.     Until (Counter = Nth) or (B = Len);
  758.     if counter = Nth then  {1.00}
  759.        NthNumber := InStr[B]
  760.     else
  761.        NthNumber := #0;
  762. end; {NthNumber}
  763. {||||||||||||||||||||||||||||||||||||||||||||||||||}
  764. {                                                  }
  765. {   F O R M A T    O B J E C T    M E T H O D S    }
  766. {                                                  }
  767. {||||||||||||||||||||||||||||||||||||||||||||||||||}
  768. constructor FmtNumberOBJ.Init;
  769. {}
  770. begin
  771.    SetPrefixSuffix('','');
  772.    SetSign(Minus);
  773.    SetSeparators(' ',',','.');
  774.    SetJustification(JustLeft);
  775. end; {FmtNumberOBJ.Init}
  776.  
  777. procedure FmtNumberOBJ.SetPrefixSuffix(P,S:string);
  778. {}
  779. begin
  780.    vPrefix := P;
  781.    vSuffix := S;
  782. end; {FmtNumberOBJ.SetPrefixSuffix}
  783.  
  784. procedure FmtNumberOBJ.SetSign(S:tSign);
  785. {}
  786. begin
  787.    vSign := S;
  788. end; {FmtNumberOBJ.SetSign}
  789.  
  790. procedure FmtNumberOBJ.SetSeparators(P,T,D:char);
  791. {}
  792. begin
  793.    vPad := P;
  794.    vThousandsSep := T;
  795.    vDecimalSep := D;
  796. end; {FmtNumberOBJ.SetSeparators}
  797.  
  798. procedure FmtNumberOBJ.SetJustification(J:tJust);
  799. {}
  800. begin
  801.    vJustification := J;
  802. end; {FmtNumberOBJ.SetJustification}
  803.  
  804. function FmtNumberOBJ.GetDecimal:char;
  805. {}
  806. begin
  807.    GetDecimal := vDecimalSep;
  808. end; {FmtNumberOBJ.GetDecimal}
  809.  
  810. function FmtNumberOBJ.FormattedStr(StrVal:string; Width:byte):string;
  811. {}
  812. var
  813.    DP: integer;
  814.    Neg: boolean;
  815.    Temp,Unformatted: string;
  816. begin
  817.    Unformatted := StrVal;
  818.    if StrVal <> '' then
  819.    begin
  820.       if (StrVal[1] = '-') then
  821.       begin
  822.          Neg := true;
  823.          delete(StrVal,1,1);
  824.       end
  825.       else
  826.          Neg := false;
  827.       DP := pos('.',StrVal);
  828.       if DP = 0 then
  829.          DP := succ(length(StrVal))
  830.       else
  831.          if vDecimalSep <> '.' then
  832.             StrVal[DP] := vDecimalSep;
  833.       dec(DP,3);
  834.       while (DP > 1) and (vThousandsSep <> #0) do    {add thousands separator}
  835.       begin
  836.          insert(vThousandsSep,StrVal,DP);
  837.          dec(DP,3);
  838.       end;
  839.       if vPrefix <> '' then
  840.          StrVal := vPrefix + StrVal;
  841.       if vSuffix <> '' then
  842.          StrVal := StrVal + vSuffix;
  843.       if Neg then
  844.          case vSign of
  845.             PlusMinus, Minus:
  846.                StrVal := '-'+StrVal;
  847.             DbCr:
  848.                StrVal := StrVal + 'DB';
  849.             Brackets:
  850.                StrVal := '('+StrVal + ')';
  851.          end {case}
  852.       else
  853.          case vSign of
  854.             PlusMinus:
  855.                StrVal := '+'+StrVal;
  856.             DbCr:
  857.                StrVal := StrVal + 'CR';
  858.          end; {case}
  859.    end;
  860.    {now see if there is room for the formatted string}
  861.    Temp := Pad(JustRight,StrVal,succ(Width),vPad);
  862.    if Temp[1] = vPad then {there was room}
  863.       FormattedStr := Pad(vJustification,StrVal,Width,vPad)
  864.    else
  865.       FormattedStr := Pad(vJustification,Unformatted,Width,vPad);
  866. end; {FmtNumberOBJ.FormattedStr}
  867.  
  868. function FmtNumberOBJ.FormattedLong(Val:longint; Width:byte):string;
  869. {}
  870. var
  871.   Str:string;
  872. begin
  873.    Str := IntToStr(Val);
  874.    FormattedLong := FormattedStr(Str,Width);
  875. end; {FmtNumberOBJ.FormattedLong}
  876.  
  877. function FmtNumberOBJ.FormattedReal(Val:extended; DP:byte; Width:byte):string;
  878. {}
  879. var
  880.   Str:string;
  881. begin
  882.    Str := RealToStr(Val,DP);
  883.    FormattedReal := FormattedStr(Str,Width);
  884. end; {FmtNumberOBJ.FormattedReal}
  885.  
  886. destructor FmtNumberOBJ.Done;
  887. {}
  888. begin end;
  889. {|||||||||||||||||||||||||||||||||||||||||||||||}
  890. {                                               }
  891. {     U N I T   I N I T I A L I Z A T I O N     }
  892. {                                               }
  893. {|||||||||||||||||||||||||||||||||||||||||||||||}
  894.  
  895. procedure StrInit;
  896. {initilizes objects and global variables}
  897. begin
  898. end;
  899.  
  900. {end of unit - add initialization routines below}
  901. {$IFNDEF OVERLAY}
  902. begin
  903.    StrInit;
  904. {$ENDIF}
  905. end.
  906.